home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / UTIL / Alpha 6.5.sit / Tcl / SystemCode / appleEvents.tcl < prev    next >
Text File  |  1996-08-15  |  8KB  |  278 lines
  1.  
  2. # make alias list to pass to AEBuild
  3. proc makeAlis {name} {
  4.     return "¥[alis(ﾇ[coerce TEXT $name -x alis]ﾈ)¥]"    
  5. }
  6.  
  7. proc makeFile {name} {
  8.     return "alis(ﾇ[coerce TEXT $name -x alis]ﾈ)"    
  9. }
  10.  
  11. proc makeAlises {args} {
  12.     set str "¥["
  13.     set sep ""
  14.     foreach name $args {
  15.         append str "${sep}alis(ﾇ[coerce TEXT $name -x alis]ﾈ)"
  16.         set sep ","
  17.     }
  18.     append str "¥]"
  19.     return $str
  20. }
  21.  
  22. # Queued replies are passed through AEPrint and then to this routine.
  23. if {![llength [info command handleReply]]} {
  24.     proc handleReply {rep} {
  25.         global ALPHA lastReply
  26.     #    switchTo $ALPHA
  27.         set lastReply $rep
  28.     }
  29. }
  30.  
  31.  
  32. # Return an object record specifying the desired think project file.
  33. proc fileObject {name} {
  34.     join [concat {obj¥{want:type('SFIL'), from:'null'(), form:'name', seld:ﾒ} [file tail $name] {ﾓ¥}}] ""
  35. }
  36.  
  37. proc sendOpenEvent {filler appname fname} {
  38.     if {$filler == "noReply"} {
  39.         AEBuild $appname aevt odoc "----" [makeAlis $fname]
  40.     } else {
  41.         AEBuild -r $appname aevt odoc "----" [makeAlis $fname]
  42.     }
  43. }
  44.  
  45.  
  46. # Send open folder event to Finder. Name must end in colon.
  47. proc openFolder {name} {
  48.     if {![regexp ".*:$" $name]} {
  49.         append name ":"
  50.     }
  51.     sendOpenEvent -r Finder $name
  52. }
  53.  
  54. proc launchDoc {name} {
  55.     set app [launchForeAppl [getFileSig $name]]
  56.     sendOpenEvent -r [file tail $app] $name
  57. }
  58.  
  59.  
  60. # Called from Alpha when titlebar "title" menu selected (command-mouse).
  61. proc getTitleBarPath {} {
  62.     global fetched
  63.     
  64.     set f [car [winNames -f]]
  65.     if {[info exists fetched($f)]} {
  66.         set nm "[car $fetched($f)]/[cadr $fetched($f)]/[file tail $f]"
  67.         regsub -all {//} $nm {/} nm
  68.         regsub -all {/} $nm {:} nm
  69.         return $nm
  70.     } else {
  71.         return $f
  72.     }
  73. }
  74.  
  75.  
  76. proc titlebar {name} {
  77.     global fetched
  78.     
  79.     if {[info exists fetched([car [winNames -f]])]} {
  80.         set specs $fetched([car [winNames -f]])
  81.         regsub -all {:} $name {/} name
  82.         regexp {[^/]+/(.*)} $name dummy dir
  83.         ftpBrowse [car $specs] $dir [caddr $specs]  [cadddr $specs] 
  84.     } else {
  85.         if {[file isdir $name]} {
  86.             switchTo Finder
  87.             openFolder $name
  88.         }
  89.     }
  90. }
  91.  
  92.  
  93. # Send multiple open events
  94. proc sendOpenEvents {appname args} {
  95.     AEBuild -r $appname aevt odoc "----" [eval makeAlises $args]
  96. }
  97.  
  98. proc openAndSendFile {sig} {
  99.     set fname [car [winNames -f]]
  100.     if {[winDirty]} {
  101.         if {[askyesno "Save '$fname'?"] == "yes"} {
  102.             save
  103.         }
  104.     }
  105.  
  106.     set name [file tail [launchForeAppl $sig]]
  107.     sendOpenEvent noReply $name $fname
  108. }
  109.  
  110. #================================================================================
  111. # General Apple Event handling routines
  112. #
  113. # (written by Tom Pollard for use in the MacPerl package)
  114. #================================================================================
  115.  
  116. # Quit an application.
  117. proc sendQuitEvent {appname} {
  118.     AEBuild $appname "aevt" "quit" 
  119. }
  120.  
  121. # Close one of an application's windows, designated by number.
  122. proc sendCloseWinNum {appname num} {
  123.     AEBuild $appname "core" "clos" "----" [AEWinByPos $num]
  124. }
  125.  
  126. # Close one of an application's windows, designated by name.
  127. proc sendCloseWinName {appname name} {
  128.     AEBuild $appname "core" "clos" "----" [AEWinByName $name]
  129. }
  130.  
  131. # Obtain the number of lines in one of an application's
  132. # windows, designated by name.
  133. proc sendCountLines {appname name} {
  134.     set winObj [AEWinByName $name]
  135.     set res [AEBuild -r $appname "core" "cnte" "----" $winObj kocl type('clin')]    
  136.     if {[regexp {:(.*)¥}} $res allofit nlines]} {
  137.         return $nlines
  138.     } else {
  139.         return 0
  140.     }
  141. }
  142.  
  143. # Get a selected range of lines from one of an application's
  144. # windows, designated by name.  If $last is missing, then a single
  145. # line is returned; if both $first and $last are missing, then
  146. # the complete window contents are returned.
  147. proc sendGetText {appname name {first {missing}} {last {missing}}} {
  148.     global ALPHA
  149.     set winObj [AEWinByName $name]
  150.     if {$first != "missing"} {
  151.         if {$last != "missing"} {
  152.             set rangDesc [AELineRange $first $last]
  153.         } else {
  154.             set rangDesc [AEAbsPos $first]
  155.         }
  156.         set objDesc "obj{want:type('clin'), from:$winObj, $rangDesc }"
  157.     } else {
  158.         set objDesc "obj{want:type('ctxt'), from:$winObj, form:'indx', seld:abso('all') }"
  159.     }
  160.     set res [AEBuild -r $appname "core" "getd" "----" $objDesc]    
  161.     if {![regexp {ﾒ.*ﾓ} $res text]} { set text {} }
  162.     return [string trim $text {ﾒﾓ}]
  163. }
  164.  
  165. # Set a selected range of lines in one of an application's
  166. # windows, designated by name.  If $last is missing, then a single
  167. # line is changed; if both $first and $last are missing, then
  168. # the complete window contents are replaced by the new text.
  169. proc sendSetText {appname name text {first {missing}} {last {missing}}} {
  170.     set winObj [AEWinByName $name]
  171.     if {$first != "missing"} {
  172.         if {$last != "missing"} {
  173.             set rangDesc [AELineRange $first $last]
  174.         } else {
  175.             set rangDesc [AEAbsPos $first]
  176.         }
  177.         set objDesc "obj{want:type('clin'), from:$winObj, $rangDesc }"
  178.     } else {
  179.         set objDesc "obj{want:type('ctxt'), from:$winObj, form:'indx', seld:abso('all') }"
  180.     }
  181.     set res [AEBuild -r $appname "core" "setd" "----" $objDesc "data" [curlyq $text]]    
  182.     if {![regexp {ﾒ.*ﾓ} $res text]} { set text {} }
  183.     return [string trim $text {ﾒﾓ}]
  184. }
  185.  
  186. ################################################################################
  187. # Utility functions for constructing AppleEvent descriptors for AEBuild
  188. ################################################################################
  189.  
  190. proc AEFilename {name} {
  191.     return "obj{want:type('file'), from:'null'(), [AEName $name] } "
  192. }
  193.  
  194. proc AEWinByName {name} {
  195.     return "obj{want:type('cwin'), from:'null'(), [AEName $name] } "
  196. }
  197.  
  198. proc AEWinByPos {absPos} {
  199.     return "obj{want:type('cwin'), from:'null'(), [AEAbsPos $absPos] } "
  200. }
  201.  
  202. proc AELineRange {absPos1 absPos2} {
  203.     set lineObj1 "obj{ want:type('clin'), from:'ccnt'(), [AEAbsPos $absPos1] }"
  204.     set lineObj2 "obj{ want:type('clin'), from:'ccnt'(), [AEAbsPos $absPos2] }"
  205.     return "form:'rang', seld:rang{star:$lineObj1, stop:$lineObj2 } "
  206. }
  207.  
  208. proc AEAbsPos {posName} {
  209. #
  210. # Use '1' or 'first' to specify first position
  211. # and '-1' or 'last' to specify last position.
  212. #
  213.     if {$posName == "first"} { 
  214.         set posName 1 
  215.     } elseif {$posName == "last"} { 
  216.         set posName -1 
  217.     }
  218.     if {$posName >= -1} {
  219.         return "form:indx, seld:long($posName)"
  220.     } else {
  221.         error "AEAbsPos: bad argument"
  222.     }
  223. }
  224.  
  225. proc AEName {name} {
  226.     return "form:'name', seld:[curlyq $name]"
  227. }
  228.  
  229. proc curlyq {str} {
  230.     return "¥ﾒ$str¥ﾓ"
  231. }
  232.  
  233. ################################################################################
  234. proc nullObject {}                     { return "'null'()" }
  235. proc objectType {type}                 { return "type($type)" }
  236. proc nameObject {type name from}     { return "obj ¥{form:name, want:[objectType $type], seld:$name, from:$from¥}" }
  237. proc indexObject {type ind from}     { return "obj ¥{form:indx, want:[objectType $type], seld:$ind, from:$from¥}" }
  238. proc propertyObject { prop object } { return "obj ¥{form:prop, want:[objectType prop], seld:[objectType $prop], from:$object¥}" }
  239.  
  240. # 'process' must have single quotes
  241. proc buildMsgReply { process suite event args } { return [eval [list AEBuild -r $process $suite $event ] $args] }
  242.  
  243. proc countObjects { process fromObject class } {
  244.     set res [AEBuild -r $process core cnte ---- $fromObject kocl [objectType $class]]
  245.     if {[regexp {:([0-9]+)} $res dummy mtch]} {
  246.         return $mtch
  247.     } else {
  248.         error "Bad count proc"
  249.     }
  250. }
  251.  
  252. proc createThingAtEnd {process container class} {
  253.     set res [AEBuild -r $process core crel insh "insl ¥{kobj:$container¥}" kocl "type($class)"]
  254. }
  255.  
  256.  
  257. proc getObjectData { process class name from } {
  258.     set res [AEBuild -r $process core getd ---- [nameObject $class "ﾒ$nameﾓ" $from] {rtyp{type:TEXT}}]
  259.     if {[regexp {ﾒ(.*)ﾓ} $res dummy mtch]} {
  260.         return $mtch
  261.     } else {
  262.         error "Bad count proc"
  263.     }
  264. }
  265.  
  266.  
  267. proc objectProperty { process property object } {
  268.     AEBuild -r $process core getd ---- [propertyObject $property $object]
  269. }
  270.  
  271. # Extract and return a path from a result.
  272. proc extractPath {res} {
  273.     if {[regexp {ﾇ(.*)ﾈ} $res dummy fss]} {
  274.         return [specToPathName $fss]
  275.     }
  276.     error "bad path $name"
  277. }    
  278.